Pensieve header: Fixing the bug with R2c.

Once[<< KnotTheory`];

Utilities. The step function, algebraic numbers, canonical forms.

θ[x_]/;NumericQ[x]:=UnitStep[x]

ω2[v_][p_]:=Module[{q=Expand[p],n,c},
If[q===0,0,c=Coefficient[q,ω,n=Exponent[q,ω]];c (v^n)+ω2[v][q-c(((ω+(ω^(-1))))^n)]]];

sign[ℰ_]:=Module[{n,d,v,p,rs,e,k},
{n,d}=NumeratorDenominator[ℰ];
{n,d}/=(ω^(Exponent[n,ω]/2+Exponent[n,ω,Min]/2));
p=Factor[ω2[v]@n*ω2[v]@d/.v->4(u^2)-2];
rs=Solve[p==0,u,Reals];
If[rs==={}, Sign[p/.u->0],
rs=Union@(u/.rs);
Sign[(((-1))^(e=Exponent[p,u]))Coefficient[p,u,e]]+Sum[
k=0;While[(d=RootReduce[(∂_({u,++k}))p/.u->r])==0];
If[EvenQ[k],0,2Sign[d]]*θ[u-r],
{r,rs}]
]
]

SetAttributes[B, Orderless];
CF[b_B]:=RotateLeft[#,First@Ordering[#]-1]&/@DeleteCases[b,{}]

CF[ℰ_]:=Module[{γs=Union@Cases[ℰ,(Subscript[γ, _])|(Subscript[(OverBar[γ]), _]),∞]},
Total[CoefficientRules[ℰ,γs]/.(ps_->c_):>Factor[c]Times@@((γs)^ps)] ]

CF[{}]={};
CF[𝒞_List]:=Module[{γs=Union@Cases[𝒞,(Subscript[γ, _]),∞],γ},
CF/@DeleteCases[0][
RowReduce[Table[(∂_γ)r,{r,𝒞},{γ,γs}]].γs]  ]

(SuperStar[(ℰ_)]):=ℰ/.{(OverBar[γ])->γ,γ->(OverBar[γ]),ω->(ω^(-1)),c_Complex:>c\[Conjugate]};
(SuperPlus[r_Rule]):={r,(SuperStar[r])}

RulesOf[(Subscript[γ, i_])+rest_.]:=(SuperPlus[((Subscript[γ, i])->-rest)]);
CF[PQ[𝒞_,q_]]:=Module[{n𝒞=CF[𝒞]},
PQ[n𝒞,CF[q/.Union@@RulesOf/@n𝒞]]  ]

CF[(Subscript[Σ, b_])[σ_,pq_]]:=(Subscript[Σ, CF[b]])[σ,CF[pq]]

Pretty-Printing.

Format[(Subscript[Σ, b_B])[σ_,PQ[𝒞_,q_]]]:=Module[{γs},
γs=(Subscript[γ, #])&/@Join@@b;
Column[{TraditionalForm@σ,
TableForm[Join[
Prepend[""]/@Table[TraditionalForm[(∂_c)r],{r,𝒞},{c,γs}],
{Prepend[""][
Join@@(b/.{l_,m___,r_}:>{DisplayForm@RowBox[{"(",l}],m,DisplayForm@RowBox[{r,")"}]})/.i_Integer:>(Subscript[γ, i]) ]},
MapThread[Prepend,{Table[TraditionalForm[(∂_(r,c))q],{r,(SuperStar[γs])},{c,γs}],(SuperStar[γs])}]
],TableAlignments->Center]
}, Center] ];

The Face-Centric Core.

(Subscript[Σ, b1_])[σ1_,PQ[𝒞1_,q1_]]⊕(Subscript[Σ, b2_])[σ2_,PQ[𝒞2_,q2_]]^:=CF@(Subscript[Σ, Join[b1,b2]])[σ1+σ2,PQ[𝒞1⋃𝒞2,q1+q2]];

GT for Gap Touch:

(Subscript[GT, i_,j_])@(Subscript[Σ, B[{li___,i_,ri___},{lj___,j_,rj___},bs___]])[σ_,PQ[𝒞_,q_]]:=CF@(Subscript[Σ, B[{ri,li,j,rj,lj,i},bs]])[σ,PQ[𝒞⋃{(Subscript[γ, i])-(Subscript[γ, j])},q]]

\par\vskip 1mm\par\Cordon

(Subscript[Cordon, i_])@(Subscript[Σ, B[{li___,i_,ri___},bs___]])[σ_,PQ[𝒞_,q_]]:=Module[{ϕ=(∂_(Subscript[γ, i]))𝒞,λ=(∂_((Subscript[(OverBar[γ]), i]),(Subscript[γ, i])))q,nσ=σ,n𝒞,nq,p},
{p}=FirstPosition[(#=!=0)&/@ϕ,True,{0}];
{n𝒞,nq}=Which[
p>0, {𝒞,q}/.(SuperPlus[((Subscript[γ, i])->-𝒞[[p]]/ϕ[[p]])])/.(SuperPlus[((Subscript[γ, i])->0)]),
λ=!=0,(nσ+=sign[λ];{𝒞,q/.(SuperPlus[((Subscript[γ, i])->-((∂_(Subscript[(OverBar[γ]), i]))q)/λ)])/.(SuperPlus[((Subscript[γ, i])->0)])}),
λ===0,{𝒞⋃{(∂_(Subscript[(OverBar[γ]), i]))q},q/.(SuperPlus[((Subscript[γ, i])->0)])}];
CF@(Subscript[Σ, B[Most@{ri,li},bs]])[nσ,PQ[n𝒞,nq]/.(SuperPlus[((Subscript[γ, Last@{ri,li}])->(Subscript[γ, First@{ri,li}]))])]  ]

Strand Operations. c for contract, mc for magnetic contract:

(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{li___,i_,ri___},{___,j_,___},___]])[__]:=t//(Subscript[GT, j,First@{ri,li}])//(Subscript[Cordon, j])

(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{___,i_,j_,___},___]])[__]:=(Subscript[Cordon, j])@t
(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{j_,___,i_},___]])[__]:=(Subscript[Cordon, j])@t
(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{___,j_,i_,___},___]])[__]:=(Subscript[Cordon, i])@t
(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{i_,___,j_},___]])[__]:=(Subscript[Cordon, i])@t

mc[ℰ_]:=ℰ//.
t:(Subscript[Σ, B[{___,i_,___},{___,j_,___},___]])[__]|(Subscript[Σ, B[{___,i_,j_,___},___]])[__]|(Subscript[Σ, B[{j_,___,i_},___]])[__]/;i+j==0:>(Subscript[c, i,j])@t

The Crossings (and empty strands).

Kas@(Subscript[P, i_,j_]):=CF@(Subscript[Σ, B[{i,j}]])[0,PQ[{},0]];
TL@(Subscript[P, i_,j_]):=CF@(Subscript[Σ, B[{i,j}]])[0,PQ[{},0]]

Kas[x:X[i_,j_,k_,l_]]:=Kas@If[PositiveQ[x],(Subscript[X, -i,j,k,-l]),(Subscript[(OverBar[X]), -j,k,l,-i])];
Kas[(Subscript[(x:X|(OverBar[X])), fs__])]:=Module[{v=2(u^2)-1,p,γs,m},
γs=(Subscript[γ, #])&/@{fs};p=(x===X);
m=If[p,(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}})),-(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}}))];
CF@(Subscript[Σ, B[{fs}]])[If[p,-1,1],PQ[{},(SuperStar[γs]).m.γs]]]

TL[x:X[i_,j_,k_,l_]]:=TL@If[PositiveQ[x],(Subscript[X, -i,j,k,-l]),(Subscript[(OverBar[X]), -j,k,l,-i])];
TL[(Subscript[(x:X|(OverBar[X])), fs__])]:=Module[{t=1-ω,r,γs,m},
r=t+(SuperStar[t]);γs=(Subscript[γ, #])&/@{fs};
m=If[x===X,
(({{-r, -t, 2t, (SuperStar[t])}, {-(SuperStar[t]), 0, (SuperStar[t]), 0}, {2(SuperStar[t]), t, -r, -(SuperStar[t])}, {t, 0, -t, 0}})),(({{r, -t, -2(SuperStar[t]), (SuperStar[t])}, {-(SuperStar[t]), 0, (SuperStar[t]), 0}, {-2t, t, r, -(SuperStar[t])}, {t, 0, -t, 0}}))];
CF@(Subscript[Σ, B[{fs}]])[0,PQ[{},(SuperStar[γs]).m.γs]]]

\par{\bf\red Evaluation on Tangles and Knots.}

Kas[K_]:=Fold[mc[#1⊕#2]&,(Subscript[Σ, B[]])[0,PQ[{},0]],List@@(Kas/@PD@K)];
KasSig[K_]:=Expand[Kas[K][[1]]/2]

TL[K_]:=Fold[mc[#1⊕#2]&,(Subscript[Σ, B[]])[0,PQ[{},0]],List@@(TL/@PD@K)]/.θ[c_+u]/;Abs[c]>=1:>θ[c];
TLSig[K_]:=TL[K][[1]]

Reidemeister 3

R3L=PD[(Subscript[X, -2,5,4,-1]),(Subscript[X, -3,7,6,-5]),
(Subscript[X, -6,9,8,-4])];
R3R=PD[(Subscript[X, -3,5,4,-2]),(Subscript[X, -4,6,8,-1]),
(Subscript[X, -5,7,9,-6])];
{TL@R3L==TL@R3R,Kas@R3L==Kas@R3R}

TL@R3L

Kas@R3L

Reidemeister 2b

TL@PD[(Subscript[X, -2,4,3,-1]),(Subscript[(OverBar[X]), -4,6,5,-3])]

{TL@PD[(Subscript[X, -2,4,3,-1]),(Subscript[(OverBar[X]), -4,6,5,-3])]==(Subscript[GT, 5,-2])@TL@PD[(Subscript[P, -1,5]),(Subscript[P, -2,6])],
Kas@PD[(Subscript[X, -2,4,3,-1]),(Subscript[(OverBar[X]), -4,6,5,-3])]==(Subscript[GT, 5,-2])@Kas@PD[(Subscript[P, -1,5]),(Subscript[P, -2,6])]}

Reidemeister 1

{TL@PD[(Subscript[X, -3,3,2,-1])]==TL@(Subscript[P, -1,2]),
Kas@PD[(Subscript[X, -3,3,2,-1])]==Kas@(Subscript[P, -1,2])}

A Knot

f=TLSig[Knot[8,5]]

Plot[f,{u,-1,1}]

Some Tangles

T1=PD[(Subscript[(OverBar[X]), -6,2,7,-1]),(Subscript[(OverBar[X]), -2,8,3,-7]),(Subscript[(OverBar[X]), -8,4,9,-3]),(Subscript[X, -11,6,12,-5]),(Subscript[X, -4,11,5,-10])];
T2=PD[(Subscript[X, -6,2,7,-1]),(Subscript[X, -2,8,3,-7]),(Subscript[X, -8,4,9,-3]),(Subscript[(OverBar[X]), -12,6,13,-5]),(Subscript[(OverBar[X]), -4,12,5,-11]),(Subscript[(OverBar[X]), -10,15,11,-14]),(Subscript[(OverBar[X]), -15,10,16,-9])];

Column@{TL[T1],Kas[T1]}

Column@{TL[T2],Kas[T2]}

Reidemeister 2c

Kas@PD[(Subscript[(OverBar[X]), -1,2,4,-3]),(Subscript[X, -6,5,3,-4])]==(Subscript[GT, 5,2])@Kas@PD[(Subscript[P, -1,5]),(Subscript[P, -6,2])]

{TL@PD[(Subscript[(OverBar[X]), -1,2,4,-3]),(Subscript[X, -6,5,3,-4])],TL@PD[(Subscript[X, -1,2,4,-3]),(Subscript[(OverBar[X]), -6,5,3,-4])]}

TL@PD[(Subscript[P, -1,5]),(Subscript[P, -6,2])]

TL@PD[(Subscript[(OverBar[X]), -1,2,4,-3]),(Subscript[X, -6,5,3,-4])]==(Subscript[GT, 5,2])@TL@PD[(Subscript[P, -1,5]),(Subscript[P, -6,2])]

That’s a fail for TL!

The flip (1,6)(4,5) on (1,6)(2,3)(4,5) on S=+-+-+-

arc15flip1=PD[(Subscript[P, -5,11]),(Subscript[P, -12,6]),(Subscript[(OverBar[X]), -13,14,15,-1]),(Subscript[X, -14,13,7,-16]),(Subscript[(OverBar[X]), -17,18,3,-2]),(Subscript[X, -24,23,8,-9]),(Subscript[(OverBar[X]), -20,19,17,-15]),(Subscript[X, -19,21,4,-18]),(Subscript[X, -22,20,16,-23]),(Subscript[(OverBar[X]), -21,22,24,-10])];
arc15flip2 = PD[(Subscript[P, -1,7]),(Subscript[P, -2,8]),(Subscript[P, -9,3]),(Subscript[P, -10,4]),(Subscript[(OverBar[X]), -13,14,6,-5]),(Subscript[X, -14,13,11,-12])];

(Subscript[GT, 4,11])@(Subscript[GT, -5,-12])@TL@arc15flip1

(Subscript[c, 6,-1])@(Subscript[c, 3,-2])@(Subscript[c, 4,-5])@(Subscript[GT, 4,11])@(Subscript[GT, -5,-12])@TL@arc15flip1

(Subscript[GT, 4,11])@(Subscript[GT, 3,-10])@(Subscript[GT, -2,-9])@(Subscript[GT, -1,8])@TL@arc15flip2

(Subscript[c, 6,-1])@(Subscript[c, 3,-2])@(Subscript[c, 4,-5])@(Subscript[GT, 4,11])@(Subscript[GT, 3,-10])@(Subscript[GT, -2,-9])@(Subscript[GT, -1,8])@TL@arc15flip2

Wrong orientation corridor flip on S = -+-++--+-+, (1,10)(2,3)(4,7)(5,6)(8,9). (Flipping (1,10) and (8,9)).

flip810a = PD[(Subscript[P, -19,9]),(Subscript[P, -10,20]),(Subscript[(OverBar[X]), -23,1,21,-22]),(Subscript[X, -11,24,22,-21]),(Subscript[(OverBar[X]), -25,26,3,-2]),(Subscript[X, -27,25,23,-28]),(Subscript[(OverBar[X]), -26,27,30,-33]),(Subscript[(OverBar[X]), -31,29,28,-24]),(Subscript[X, -29,32,34,-30]),(Subscript[X, -32,31,12,-13]),(Subscript[(OverBar[X]), -35,36,6,-5]),(Subscript[(OverBar[X]), -37,38,35,-4]),(Subscript[X, -39,40,7,-36]),(Subscript[(OverBar[X]), -41,42,39,-38]),(Subscript[X, -59,60,15,-16]),(Subscript[X, -57,53,14,-60]),(Subscript[(OverBar[X]), -56,58,59,-17]),(Subscript[X, -55,54,57,-58]),(Subscript[X, -43,37,33,-46]),(Subscript[X, -44,41,43,-47]),(Subscript[(OverBar[X]), -53,50,46,-34]),(Subscript[(OverBar[X]), -54,51,47,-50]),(Subscript[(OverBar[X]), -42,44,48,-45]),(Subscript[(OverBar[X]), -40,45,49,-8]),(Subscript[X, -51,55,52,-48]),(Subscript[X, -52,56,18,-49])];
flip810b = PD[(Subscript[P, -11,1]),(Subscript[P, -2,12]),(Subscript[P, -13,3]),(Subscript[P, -4,14]),(Subscript[P, -5,15]),(Subscript[P, -16,6]),(Subscript[P, -17,7]),(Subscript[P, -8,18]),(Subscript[(OverBar[X]), -10,9,21,-22]),(Subscript[X, -19,20,22,-21])];

(Subscript[GT, 9,20])@(Subscript[GT, -8,-19])@TL@flip810a

(Subscript[c, 1,-10])@(Subscript[c, -4,7])@(Subscript[c, -5,6])@(Subscript[c, -8,9])@(Subscript[c, -2,3])@(Subscript[GT, 9,20])@(Subscript[GT, -8,-19])@TL@flip810a

(Subscript[GT, -8,-19])@(Subscript[GT, 7,18])@(Subscript[GT, 6,-17])@(Subscript[GT, -5,-16])@(Subscript[GT, -4,15])@(Subscript[GT, 3,14])@(Subscript[GT, -2,-13])@(Subscript[GT, 1,12])@TL@flip810b

(Subscript[c, 1,-10])@(Subscript[c, -4,7])@(Subscript[c, -5,6])@(Subscript[c, -8,9])@(Subscript[c, -2,3])@(Subscript[GT, -8,-19])@(Subscript[GT, 7,18])@(Subscript[GT, 6,-17])@(Subscript[GT, -5,-16])@(Subscript[GT, -4,15])@(Subscript[GT, 3,14])@(Subscript[GT, -2,-13])@(Subscript[GT, 1,12])@TL@flip810b

Correct orientation corridor flip on S = --+--+++-+, (1,10)(2,3)(4,7)(5,6)(8,9) (flipping (1,10) and (8,9)

flip810c = PD[(Subscript[P, -19,9]),(Subscript[P, -10,20]),(Subscript[(OverBar[X]), -23,1,21,-22]),(Subscript[X, -11,24,22,-21]),(Subscript[(OverBar[X]), -3,2,25,-26]),(Subscript[(OverBar[X]), -25,23,28,-27]),(Subscript[X, -33,26,27,-30]),(Subscript[X, -24,31,29,-28]),(Subscript[(OverBar[X]), -32,34,30,-29]),(Subscript[X, -12,13,32,-31]),(Subscript[(OverBar[X]), -6,5,35,-36]),(Subscript[(OverBar[X]), -35,4,37,-38]),(Subscript[X, -7,36,39,-40]),(Subscript[(OverBar[X]), -39,38,41,-42]),(Subscript[X, -57,58,55,-54]),(Subscript[X, -14,60,57,-53]),(Subscript[(OverBar[X]), -59,17,56,-58]),(Subscript[X, -15,16,59,-60]),(Subscript[(OverBar[X]), -37,33,46,-43]),(Subscript[(OverBar[X]), -41,43,47,-44]),(Subscript[X, -34,53,50,-46]),(Subscript[X, -50,54,51,-47]),(Subscript[X, -45,42,44,-48]),(Subscript[X, -8,40,45,-49]),(Subscript[(OverBar[X]), -55,52,48,-51]),(Subscript[(OverBar[X]), -56,18,49,-52])];
flip810d = PD[(Subscript[P, -11,1]),(Subscript[P, -12,2]),(Subscript[P, -3,13]),(Subscript[P, -14,4]),(Subscript[P, -15,5]),(Subscript[P, -6,16]),(Subscript[P, -7,17]),(Subscript[P, -8,18]),(Subscript[(OverBar[X]), -10,9,21,-22]),(Subscript[X, -19,20,22,-21])];

(Subscript[GT, 9,20])@(Subscript[GT, -8,-19])@TL@flip810c

(Subscript[c, 1,-10])@(Subscript[c, 9,-8])@(Subscript[c, 4,-7])@(Subscript[c, 5,-6])@(Subscript[c, 2,-3])@(Subscript[GT, 9,20])@(Subscript[GT, -8,-19])@TL@flip810c

(Subscript[GT, -8,-19])@(Subscript[GT, -7,18])@(Subscript[GT, -6,17])@(Subscript[GT, 5,16])@(Subscript[GT, 4,-15])@(Subscript[GT, -3,-14])@(Subscript[GT, 2,13])@(Subscript[GT, 1,-12])@TL@flip810d

(Subscript[c, 1,-10])@(Subscript[c, 9,-8])@(Subscript[c, 4,-7])@(Subscript[c, 5,-6])@(Subscript[c, 2,-3])@(Subscript[GT, -8,-19])@(Subscript[GT, -7,18])@(Subscript[GT, -6,17])@(Subscript[GT, 5,16])@(Subscript[GT, 4,-15])@(Subscript[GT, -3,-14])@(Subscript[GT, 2,13])@(Subscript[GT, 1,-12])@TL@flip810d

6 endpoint flip variants

flip23 = PD[(Subscript[P, -1,7]),(Subscript[P, -10,4]),(Subscript[P, -5,11]),(Subscript[P, -12,6]),(Subscript[(OverBar[X]), -3,2,13,-14]),(Subscript[X, -8,9,14,-13])];
flip16 = PD[(Subscript[P, -8,2]),(Subscript[P, -3,9]),(Subscript[P, -10,4]),(Subscript[P, -5,11]),(Subscript[(OverBar[X]), -1,6,13,-14]),(Subscript[X, -12,7,14,-13])];
flip34 = PD[(Subscript[P, -1,7]),(Subscript[P, -8,2]),(Subscript[P, -5,11]),(Subscript[P, -12,6]),(Subscript[(OverBar[X]), -13,14,4,-3]),(Subscript[X, -14,13,9,-10])];
flip56 = PD[(Subscript[P, -1,7]),(Subscript[P, -8,2]),(Subscript[P, -3,9]),(Subscript[P, -10,4]),(Subscript[(OverBar[X]), -13,14,6,-5]),(Subscript[X, -14,13,11,-12])];
flip12 = PD[(Subscript[P, -3,9]),(Subscript[P, -10,4]),(Subscript[P, -5,11]),(Subscript[P, -12,6]),(Subscript[(OverBar[X]), -13,14,2,-1]),(Subscript[X, -14,13,7,-8])];

S = ++--+-, matching (1,6)(2,3)(4,5). Comparing two methods of doing (1,6)(4,5) flip.

(Subscript[GT, -5,-12])@(Subscript[GT, 4,11])@(Subscript[GT, -3,-10])@(Subscript[GT, -1,-8])@TL@flip23

(Subscript[c, -1,2])@(Subscript[c, -3,6])@(Subscript[c, 4,-5])@(Subscript[GT, -5,-12])@(Subscript[GT, 4,11])@(Subscript[GT, -3,-10])@(Subscript[GT, -1,-8])@TL@flip23

(Subscript[GT, 4,11])@(Subscript[GT, -3,-10])@(Subscript[GT, 2,9])@(Subscript[GT, -1,-8])@TL@flip16

(Subscript[c, -3,6])@(Subscript[c, -1,2])@(Subscript[c, 4,-5])@(Subscript[GT, 4,11])@(Subscript[GT, -3,-10])@(Subscript[GT, 2,9])@(Subscript[GT, -1,-8])@TL@flip16